perm filename T3.FOR[ZZZ,LCS] blob sn#439863 filedate 1979-05-08 generic text, type T, neo UTF8
      SUBROUTINE MSCAN
	INTEGER*4 INST,INAM
      DIMENSION TONES(21)
	COMMON LL  /P/W(1)
CIN   COMMON /TR/I(80),RX(100),JX(100),LX(12),INST(27,4),K
CC      COMMON /I/I(1) /TR/RX(80),JX(80),LX(12),K 
	COMMON /ROUT/I(200),RX(80),JX(80) /TR/LX(12),K
     1,INSNUM(27),P(30),NPAR(27),JSEM,IPRNT,IPP
     1,SRATE,RNCHN,RMAG,INUM,INS,MM,M,N,JJ,X,Y,IK
     1,ENDX,J  /KNAM/IPLAY,JFLNM /INST/INST(1)
	COMMON /DEVS/ID1,ID21,JTYPE,ID23,ID20
      COMMON /SBFILN/SBFILN /AR/IOP /IGEN/IGEN /JP/JPRNT
      INTEGER RPR
      EQUIVALENCE (LESS,LX(9)),(W1,W(1)),(W2,W(2)),(W3,W(3)),(W4,W(4)),
     1 (RX2,RX(3)),(P2,P(2)),(RX3,RX(5)),(I3,I(3))
     1 ,(ISEMI,LX(2)),(IAST,LX(3)),(LEQUAL,LX(8))
     1,(LPR,LX(11)),(RPR,LX(12)),(ICOM,LX(10)),(LAROW,LX(7))
      DATA TONES/246.945,261.62,277.18,277.8,293.66,311.13,311.13,
     1 329.63,349.23,329.63,349.23,369.99,369.99,
     1 391.99,415.31,415.31,440.0,466.16,466.16,493.89,523.24/

C**** CODE NUMS. 1=OUT 2=OSC 3=AD2 4=RAN 5=END 6=STR 7=AD3 8=AD4 9=MLT
C**** 10=DIV 11=RAH 12=END 13=REV 14=OPT 15=NOS 16=SUB 17=INP  18=COS
C**** B1=101 ETC.  P1=201 ETC.  F1=301 ETC. FREQ-PARAMS=600S, DURS=700S.
C**** 400=PLAY 401=FINI 402=SRATE 403=NCHNS 404=PRINT 405=CHA 
C**** 407=SRT 409=GEN 410=SEG 411=SIN  412=INS 413=UNIT GEN.
C**** 500=CF 501=C 502=CS 503=DF 504=D 505=DS 506=EF 507=E 508=ES 509=FF
C**** 510=F 511=FS 512=GF 513=G 514=GS 515=AF 516=A 517=AS 518=BF 519=B 520=BS

	JSEM=0
C IS THIS NEEDED HERE?
C JSEM=0 FOR 'PLAY' OR ASSIGNMENT ( P3←440;,  A=444; ETC.)
      LL=1
      INS=-1
34      J=J+2      
2324	FORMAT(1X20F10.3/)
2325	FORMAT(1X20I/)
2323	FORMAT(1X20A1/)
      IXJ=JX(J)      
      IPP=0             
C!FOR 'P3←333;' ETC.
      IOP=-1
9      IF(J.GE.MM)GO TO 1001  
      IF(RX(J+1).EQ.-9999.0)GO TO 11  
C!*** SKIP IF NUMBER
      IF(IGEN.GT.0)GO TO 450
C IGEN=2=INSIDE AN INST. DEFINITION.

C!***** LOOK FOR SPECIAL WORDS
	IF(IXJ/400.NE.1)GO TO 402
	K=IXJ-399
C			   PRINT
       GO TO (13,13,304,303,302,303,4,505,505,422,422,422,32)K
C 	(PLAY) FINI SRAT NCHN   CHA   SRT     GEN SEG SIN INS
32      W1=2
	IXJ=13
	JX(J)=13
      IGEN=2
      GO TO 424
505      JK=4         
C !**** FOR SRT
      IF(K.NE.4)JK=2      
      JK=J+JK
      GO TO 304

450	K=IXJ
C** HERE FOR INST DEFINITIONS.
C 14='OPT' USER-ADDED UNIT GENERATOR.
	IF(K.EQ.12)GO TO 412
	IF(K.GT.0)GO TO 425
	GO TO 1001
504      FORMAT(' UNKNOWN SYMBOL ',A4)
412       LL=3
      IGEN=1   
C!*** =1 IS FLAG TO CHANGE IT TO -1
      J=MM
      INS=-1
      GO TO 10  
422      W1=3   
C!***** GEN
	IF(K.GT.10)W1=K-4
C SEG=11, SIN=12  AT THIS POINT.
      IGEN=0
424      INS=-1
      LL=2
      GO TO 36
425      W3=K+100
436      LL=4  
      GO TO 36

4      JL=LL
      JOP=IOP
      J=J+2
      IF(JX(J).NE.LPR)CALL ERR(2)
      IOP=-1
      GO TO 36  
C!**FIND NUM UP TO THE COMMA
302      LL=1
      IPRNT=-1    
C!***** FOR 'PRINT' FEATURE
      GO TO 36
304      SRATE=RX(J+4)
      J=J+6
      RMAG=512./SRATE
      W3=4
      W4=SRATE
351      W1=11
      W2=0
      IGEN=0
      LL=5
C JSEM=-1  = SEND DATA BACK TO MUS5,PASS3.
10	JSEM=-1
	RETURN
303   RNCHN=RX(J+4)    
C!**** FOR NCHNS←N;  OR  CHA ← N;
      J=J+6
352      W3=8            
C!*** FOR NCHNS
      W4=RNCHN-1
      GO TO 351
36      J=J+2      
      IF(J.GT.MM)GO TO 1001        
C!******  50 = DONE
	IF(IPLAY.LT.0)P(LL-3)=W(LL-1)
C  **** LL HAD BETTER ALWAYS BE >3 HERE.
C  FILL UP PARAM LIST WITH DATA FOLLOWING INST NAME.
1002  	IXJ=JX(J)
	IF(IXJ.NE.ISEMI)GO TO 1
	IPLAY=0
1000      IF(IPP.EQ.0)GO TO 10
      P(IPP)=W1
      LL=1
      IPP=0
      IF(J.LT.MM)GO TO 34  
      INS=-1   
C!*** I HOPE THIS IS THE RIGHT PLACE FOR THIS.
CX	PAUSE 'LABEL 1001'
1001      JSEM=0
	RETURN

1      IF(RX(J+1).NE.-9999.0)GO TO 2
CX	TYPE 2325,IOP
CX	PAUSE 'LABEL 1'
11	IF(IOP.LT.0)GO TO 40
      IF(IOP.NE.6)GO TO 12
      RX(J)=-RX(J)  
C!*** IOP=6 MEANS MINUS WITH COMMA IN FRONT
      W(LL)=RX(J)
      LL=LL+1
      GO TO 14
12	CALL ARITH(RX(J),W,LL)
14      IOP=-1    
C!*** RESET OPERATOR FLAG
      GO TO 36   
C!*** USE PARENTH'S FOR COMPOSITE EXPRESSIONS!!!!

40	     W(LL)=RX(J)
38      LL=LL+1
      IF(IOP.LT.0)GO TO 36
C IOP = NEG = NO OPERATOR BEFORE THIS ITEM.
      LL=LL-1
380      CALL ARITH(W(LL),W,LL)
      GO TO 14

C!**** READING CONTINUATION LINE.
402	IF(IXJ.GE.0)GO TO 33
C NEXT TRIES TO FIND INST. NAME.
C NA POINTS TO SPOT IN I ARRAY, M IS WDCNT.
	CALL PACKER(INAM,I(-IXJ))
	DO 233 IK=1,INUM
233	IF(INST(IK).EQ.INAM)GO TO 333
	TYPE 504,INAM
	GO TO 33
333	IPLAY=-1
C FLAG TO START FILLING PARAMS.
      W2=INSNUM(IK)      
C!**** W IS P ARRAY IN MUSIC5
      LL=3      
C!**** W2 AND W3 WILL BE EXCHANGED LATER
	J=J+2
	GO TO 1002
33    INS=2      
C! NEXT IS SOMETHING OUTSIDE OF INST. AND PARAMS.

2      IF(IGEN.GT.0)GO TO 427
	IF(IXJ.GT.520)GO TO 341
	IF(IXJ.LT.500)GO TO 427
C NOW FOUND A NOTE
	K=IXJ-499
      W(LL)=TONES(K)
      GO TO 38
C!***** FINDS NOTE IN SCALE

C!****** FIND A PARAM NUM.
427	IF(IXJ.GE.300)GO TO 307
	IF(IXJ.LT.200)GO TO 344
	K=IXJ-200
C NOW K HAS PARAM NUM.
      IF(INS.LE.0)GO TO 340
      JK=J+2      
CCC   IF(JX(JK).NE.LAROW)GO TO 340
      IF(JX(JK).NE.LEQUAL)GO TO 340
      IPP=K
      LL=1
      J=JK      
      GO TO 36
340      W(LL)=P(K)      
C!***** FOUND Pn
      IF(IPRNT.LT.0)GO TO 38
      IF(IGEN.GT.0)W(LL)=K+2.  
C!*** PARAM NUMS ARE 2 LESS THAN IN BOOK.
      GO TO 38    
C!**** P4 IS CHANGED TO 6
307    IF(IXJ.GE.400)GO TO 344

	IF(IXJ/300.NE.1)GO TO 344
	JL=IXJ-300
      IF(IGEN.GT.0)JL=-JL-100      
C!*** FOR Fn IN INST DEFINITION
      W(LL)=JL
      GO TO 38

344      IF(IGEN.LE.0)GO TO 341
C*** FOR B1, ETC. IN INST. DEFS.
	IF(IXJ/100.NE.1)GO TO 341
	 W(LL)=100-IXJ
      GO TO 38

341      DO 39 K=3,6
      IF(LX(K).NE.IXJ)GO TO 39
	IF(K.NE.3)GO TO 342
	IF(JX(J+2).NE.IAST)GO TO 342
C NOW FOUND 'X**Y', =X TO THE POWER OF Y
	K=7
	J=J+2
342      IOP=K-2
C IOP NUMS ARE: 1=+  2=-  3=*  4=/  5=**
      JK=JX(J-2)
      IF(JK.EQ.ICOM)IOP=6 
C!** COMMA DISABLES NEXT OPERATOR
      IF(JK.EQ.LEQUAL)IOP=6 
CCC   IF(JK.EQ.LAROW)IOP=6 
C!**  ← DISABLES NEXT OPERATOR
      IF(JK.EQ.LPR)IOP=6 
C!** LFT PARENTH. DISABLES NEXT OPERATOR
      GO TO 36
39      CONTINUE
CCC308      IF(IXJ.EQ.LAROW)GO TO 36   
308      IF(IXJ.EQ.LEQUAL)GO TO 36   
C!*** PASS LEFT ARROW
	IF(IXJ.EQ.RPR)GO TO 500
	IF(IXJ.EQ.LPR)GO TO 500
C LEFT AND RIGHT PARENTHESES
	IF(IXJ.NE.402)GO TO 510
C 402=SRATE
	W(LL)=SRATE
335      LL=LL+1
      GO TO 36
C**** OR SHOULD NEXT BE 403???
510      IF(IXJ.NE.403)GO TO 511
C 403-'NCHNS'
      W(LL)=RNCHN
      GO TO 335
511      IF(IXJ.NE.ICOM)RETURN
C!***** UNKNOWN CHAR.
500      IF(IXJ.NE.LPR)GO TO 501
      KOP=IOP
      IOP=-1
      JL=LL      
C!**** SAVE VARIOUS POINTERS WHEN INSIDE PARENTHS.
      GO TO 36
501      IF(IXJ.NE.RPR)GO TO 502
C!*** GET BACK STUFF
      IOP=KOP
      IF(IOP.LT.0)GO TO 36
      LL=JL
      GO TO 380      
C!GO DO ARITHMETIC
502      IF(IPRNT.LT.0)GO TO 36     
C!**** FOUND COMMA IN PRINT STATEMENT.
5      IF(JX(J-2).NE.ICOM)GO TO 132
433      W(LL)=P(LL-2)   
C!** ONLY CARES ABOUT 2 COMMAS IN A ROW
      GO TO 335
132      IF(INS.GE.0)GO TO 36
CC      IF(LL.EQ.3)GO TO 433      
        IF(LL.NE.3.OR.IGEN.GE.0)GO TO 36      
C!*** =3 MEANS COMMA FOR P1. (CHECK "IGEN" ABOVE ?)
	GO TO 433

13      LL=2
      W1=6
CC      W2=ENDX+.5   
	W2=ENDX
C!***** ENDX IS P1+P2 OF THE LONGEST LASTING INST.
      IF(JPRNT)WRITE(JTYPE,51)LL,W1,W2
130      J=MM
C!*** WON'T READ LINE BEYOND 'FINISH;'  ***************
      ENDX=-1
51      FORMAT(I3,35F10.3)
      END